perm filename PAGE.F4[PAG,LCS]3 blob
sn#374022 filedate 1978-08-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C THIS AIDS IN EXTRACTING PARTS FROM SCORES AND DOES AUTOMATIC PAGE LAYOUT.
C00025 ENDMK
C⊗;
C THIS AIDS IN EXTRACTING PARTS FROM SCORES AND DOES AUTOMATIC PAGE LAYOUT.
C***************************** THERE ARE STILL SEVERAL BUGS IN THIS PROG.
C***************************** TRANSPOSE-ONLY IS NOT FULLY TESTED.
C*********** TRANSPOSITION OF 'F' PARTS IN BASS CLEF HAS SOME PROBLEMS.
C***************************** ETC., ETC. 8/78
C SEE PAGE.CMD FOR LOADING INSTRUCTIONS
C **** SUBROUTINE LIST *****
C PAGE: READX
C RESPC:
C RESTP:
C WRTPAG:
C PGSUB: FILOUT(NAMQ,NPG), FILEIN, STAVES
C TRONLY:
C TRNSP: TRNSP, RVRS
C PTMOVX: PTMOVE, TURN
C FNDTRN: MNMX, FNDTRN, BRJUGL, GET
C PFAIL: LOOKF,LOOKX,LOOK,SHFTQ,SORT2,NORH,FNDEND,MINMAX,RLOOP,BLTEM,IFIX,FLOAT
C GETPTS,MOVIT,EXTEN,DBAR,QRN,SORT,SHIFT,SHFT1,SHFT0,PSHFT,ADRST,STAFF
C RIGHT,RESTS,EXCHG,EXCH,SHRNK,EXPND,CLFNUM,SLRV,CLEFN,MMNN,CODEN,ZERO
C EXT: PUTEXT,EXTOUT,GETEXT,EXTIN,FINEXT
COMMON/STF/RSTFAC(0/7),RSTJ2 /POSI/STFF(0/7),JJ2,JPQ
1 /IPG/IPG,JPG,BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),
1 RCLEF(0/7) /RSIG/RSIG(0/7) /IVV/NRD(200)
COMMON RS,JA,REST,J2,RQ(18),JX,PR,LX,RDIS
C ORDER OF COMMON BLOCKS **MUST** STAY AS IS!
COMMON/XRN/RN(3000) /SF/KL,RT,KP,STFSZ,NAMX,EXT
1 /PTR/KWDS(300)/LLL/L,LL,I,IX,XSIG/XXX/LK,LP,JY /JN/J,N
C INCREASE DIMENSION OF KWDS (KPN & Q) FOR VERY FULL PAGES.
DIMENSION MM(1500),NN(1500),BARS(509),STFNM(0/7),
1 RMETER(0/7),RCL(0/7),NUMS(30),PGTRN(500)
COMMON /PX/KPN(350) /Q/Q(3500) /KBAR/KBAR(1027) /IRST/IRST
1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,RNAM2,RNAM3
1 /RSP/KNM(100) /ENDL/ENDLN,KQ,NAME,NMPG,SPCNT,LASTNM
DATA FIB/.7/,RSPC/25./,PGNUM/1.6/,RNMHT/16.0/,RNMSZ/1.0/
1 ,RLTRSZ/1.0/,SPCPG/2.7/
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
1,(MM,RN),(NN,RN(1501)),(KS,RS),(BARS,KBAR(4)),(JRSTF,RSTJ2)
1,(R8,RQ(6)),(R9,RQ(7)),(RQ(10),XLFT),(KBR,KBAR),(T,KBAR(2))
1,(STFNM,KBAR(508)),(NUMS,KPN),(PGTRN(1),KBAR(5 16))
C HANDLES 503 PAGES AND PAGE-TURN INFO. IN KBAR AND PGTRN
C RQ(2) IS R4, RQ(3) IS R5 ETC. STAFF NAMES START AT KBAR(508)=STF(0)
RN(2)=0
EXT='DMD'
IRST=0
C IRST IS USED IN SUBROUTINE RESTP
IPG=0
KBR=0
NMPG='PAGEA'
JPG=0
JRD=1
ENDLN=0
SAVSIZ=0
ISN=0
TYPE 1000
ACCEPT 2000,NAMX
IF(NAMX.EQ.0)CALL PT2
IF(NAMX.EQ.3)CALL TRONLY
NPG=NAMX-2
TYPE 3300
IF(NPG.GE.0)GO TO 3000
CC IF(NPG.GE.0)TYPE 3
ACCEPT 2,KS,NTYPE
C TYPE -1 AFTER NAME(I.E.5 SPACES) TO PRINT INST. NAMES AS READ.
CC NAMZ=KS
JNM=1
143 CALL IFILE(1,KS)
READ(1,2)K
CC843 READ(1,2)K
IF(K.NE.'COMME')GO TO 543
743 READ(1,643),K,K,K
C READ ET DIRECTORY !∃∀ βλπα∀πεβα!ββX!
IF(K.NE.';')GO TO 743
READ(1,2)K
GO TO 843
C FIRST LINE MUST BE EXTENSION NAME
643 FORMAT(3A1)
2 FORMAT(A5,30I)
CC3 FORMAT(' TYPE FILE NAME.EXT -- '$)
3300 FORMAT(' TYPE FILE NAME -- '$)
1000 FORMAT(' 1=PARTS, 2=PAGE LAYOUT, 3=TRNSP ONLY, 0=OLD '$)
2000 FORMAT(I)
CC543 READ(1,2,END=343),KNM(JNM),(KPN(K),K=1,30)
543 CALL IFILE(1,KS)
843 CALL READX(1,KNM(JNM),EXT,KEND,NUMS)
IF(KEND)GO TO 343
JNM=JNM+1
DO 434 K=1,30
J=KPN(K)
JPG=JPG+1
NRD(JPG)=J
C BE CAREFUL ABOUT RUNNING OVER NRD ARRAY (100)-- ZEROS ARE INSERTED***********
434 IF(J.EQ.0)GO TO 843
GO TO 843
CC3000 CALL NAMEXT
3000 CALL READX(5,NAMX,EXT,KEND,NUMS)
KNM(1)=NAMX
GO TO 4000
343 KNM(JNM)=-1
NXX=NRD(1)
C NXX COULD BE EQUIV. TO NRD(1)!!
4000 NAMZ=KNM(1)
DO 911 K=0,7
RCLEF(K)=99
RCL(K)=99
RMETER(K)=99
C INITS STUFF FOR PAGE LAYOUT
BRACK(K)=0
911 RSIG(K)=99
744 XSIG=FIB
CLEF=-1
XMTR=FIB
XLFT=0
JPG=0
YCLEF=2.
YSIG=2.
YMTR=2.
RSTAFF=0
RM=0
JNM=1
CZ1344 JNM=1
1344 ZLFT=.5
KQ=0
IF(NPG.EQ.0)JRD=0
L=1
LK=1
86 FORMAT(1XA5)
186 FORMAT(1XA5,'.',A3)
83 NAME=KNM(JNM)
CZ JNM=JNM+1
IF(NAME.EQ.-1)GO TO 1212
CC JRD=JRD+1
CXCX NXX=NRD(JRD+1)
CZ NXX=NRD(JRD)
C????????????? IF(KBR.EQ.0)GO TO 284
JZ=-1
10 IF(LOOKX(NAME,EXT))GO TO 284
CZ100 IF(JZ)GO TO 344
C FOUND NO MORE TO READ
344 NAME=NAMZ+256
NAMZ=NAME
CZ JZ=0
KNM(JNM)=NAME
IF(LOOKX(NAME,EXT))GO TO 284
CZ IF(LOOKX(NAME,EXT).GE.0)GO TO 284
1212 CALL PUTEXT('BARS','PAG')
CALL EXTOUT(KBAR,1024)
RSTJ2=SAVSIZ
CALL EXTOUT(RSTFAC,128)
CALL FINEXT
C K (NUM OF BARS - UP TO 511) IS FIRST LOC OF KBAR.
CALL PT2(KPN,Q,KWDS,RN)
284 JZ=0
SN=0
IF(NPG)SN=200
SNMTR=SN
IF(RM.NE.0)GO TO 277
RM=-1
4 FORMAT(' TYPE INST NAME '$)
IF(NPG.GE.0)GO TO 277
TYPE 4
ACCEPT 2,RNAM,K
RNAM2=-1
RNAM3=-1
RNAM4=-1
IF(K.EQ.0)GO TO 277
TYPE 177
ACCEPT 2,RNAM2,K
IF(K.EQ.0)GO TO 277
C TYPE NUM AFTER NAME TO ENTER UP TO 4 NAMES.
TYPE 177
ACCEPT 2,RNAM3
TYPE 177
ACCEPT 2,RNAM4
177 FORMAT(' OTHER INST NAME ',$)
277 TYPE 186,NAME,EXT
CALL GETEXT(NAME,EXT)
C LP IS START OF RN ARRAY THIS TIME
CALL EXTIN(RSTFAC,20)
CALL EXTIN(KWDS,JJ2)
CALL EXTIN(RN,JPQ)
IF(JRSTF.LT.10000)RSTJ2=1.0
C X!Z+*↑: WHERE IS THE BUG THAT PUTS AN INTEGER INTO RSTJ2????
CZ IF(SAVSIZ.EQ.0)SAVSIZ=RSTJ2
IPG=NPG
C IPG MUST BE RESET EACH TIME BECAUSE READIN WIPES IT OUT.
CALL RLOOP(Q,RN,JPQ)
ITEM=JJ2-2
1211 R=RN(KWDS(1)+2)
K=2
LS=1
J=0
C SORTS NOTES AND RHYTH ONLY
1111 KX=KWDS(K)
RA=RN(KX+2)
IF(RA.GE.R)GO TO 1011
CALL EXCH(KWDS(K),KWDS(LS))
J=-1
1011 R=RA
2611 LS=K
K=K+1
IF(K.LE.ITEM)GO TO 1111
IF(J)GO TO 1211
C NOW ALL SORTED (BY STAFF)
J=1
KW=1
DO 1311 K=1,ITEM
LS=KWDS(K)
IF(RN(LS+1).GT.2)GO TO 2711
RN(LS+3)=RN(LS+3)-.001
C MOVE ALL NOTES AND RESTS SLIGHTLY TO LEFT. (FOR SORTER)
2711 M=RN(LS)+3
CALL RLOOP(Q(J),RN(LS),M)
J=J+M
KPN(K)=KW
1311 KW=KW+M
KPN(ITEM+1)=KW
CC DO 1511 K=1,ITEM+1
CC1511 KWDS(K)=KPN(K)
CC DO 1611 K=1,JPQ
CC1611 RN(K)=Q(K)
CALL BLTEM
C BLTEM BLTS ARRAYS KPN AND Q INTO KWDS AND RN
RLFT=10000
811 DO 577 K=1,ITEM
R=CODEN(KWDS,K,RN,J)
IF(R.GT.2)GO TO 809
IF(RLFT.GT.RN(J+3))RLFT=RN(J+3)
C RLFT IS LEFT-MOST NOTE OR REST. USED FOR DISCARDING ENTERING SLURS.
GO TO 577
809 IF(R.LT.4)GO TO 577
RWD=RN(J)
C RWD IS WDCNT OF EACH ITEM
JS=RN(J+2)
IF(IPG)GO TO 111
C IPG=-1 = EXTRACTING PARTS, =0 = PAGE LAYOUT.
IF(R.NE.8)GO TO 211
STFNM(JS)=0
IF(RWD.GE.7)STFNM(JS)=RN(J+9)
CC **** 10/77 IF(RWD.LE.7)STFNM(JS)=RN(J+9)
C SAVES STAFF IDENT. NAME
1811 IF(ENDLN.NE.0)GO TO 577
JPG=JPG+1
LS=JS+1
CC R5=RN(J+2)
CC RSTNUM(LS)=R5
RSTNUM(LS)=JS
RHGT(LS)=0
IF(RWD.GE.2)RHGT(LS)=RN(J+4)
RPSZ(LS)=RSTFAC(JS)
IF(SAVSIZ.EQ.0)SAVSIZ=RPSZ(LS)
CC RPSZ(LS)=RSTFAC(IFIX(R5))
C***211 RN(J+2)=RN(J+2)*.1
C*** STAFF NUMS WILL NOW BE -.3 UP TO +.4. NO STAFF NAME NEEDED.
IF(R5.EQ.0)SPCNT=SPCPG*RPSZ(LS)
211 IF(R.NE.4)GO TO 577
IF(RN(J+3).LT.ZLFT)GO TO 311
C ASSUMES STAFF, LFT POS., HAS ALREADY BEEN SEEN. (ZLFT=P3+.5)
IF(RN(J+2).EQ.0)GO TO 577
511 RN(J+1)=44
C BARS NOT ON STAFF ZERO NOW HAVE CODE NUM. 44
GO TO 577
311 IF(IPG)GO TO 577
IF(ENDLN.NE.0)GO TO 577
CC IF(RWD.GE.5)BRACK(LS)=RN(J+7)+RN(J+4)*100.
IF(RWD.GE.5)BRACK(JS)=RN(J+7)+RN(J+4)*100.
C SAVE 'BRACKET' INFO (P7=3,4 OR 5) - CAN FIND WRONG THING!!
CCC IF(RWD.GE.5)GO TO 511
GO TO 577
111 IF(R.NE.8)GO TO 577
IF(RWD.LT.7)GO TO 577
C NO NAME ON THIS STAFF - SO JUMP
IF(RN(J+7).NE.0)GO TO 577
C SKIPS INVISIBLE STAVES.
XLFT=RN(J+3)
C LEFT LIMIT OF STAFF
R9=RN(J+9)
IF(NTYPE)TYPE 86,R9
IF(R9.EQ.RNAM)GO TO 977
IF(RNAM2.EQ.R9)GO TO 977
IF(RNAM3.EQ.R9)GO TO 977
IF(RNAM4.NE.R9)GO TO 577
977 I=JS+RSTAFF
SN=I
SNMTR=SN
RPSZ(1)=RSTFAC(JS)
IF(SAVSIZ.EQ.0)SAVSIZ=RPSZ(1)
IF(NXX.GT.1)NXX=-NXX
C SO IT WON'T LOOK ON MORE STAVES IN OTHER FILES.
GO TO 477
577 CONTINUE
C DIDN'T FIND USEFUL INFO SO SKIP THIS FILE
IF(IPG)TYPE 1577,RNAM,NAME
1577 FORMAT(1XA5,' NOT FOUND IN ',A5)
477 I=JPQ-2
C READS AND WRITES 1 EXTRA WORD
IF(IPG.EQ.0)GO TO 13
IF(NXX.GT.0)GO TO 877
C NEXT FOR PARTS ONLY. TO SKIP A FILE (OR MORE)
NAME=NAME-2*(NXX+1)
NXX=1
877 NXX=NXX-1
KNM(JNM)=NAME
NAME=NAME+2
IF(NXX.NE.0)GO TO 277
JRD=JRD+1
NXX=NRD(JRD)
IF(NXX.NE.0)GO TO 44
JNM=JNM+1
NAMZ=KNM(JNM)
KNM(JNM)=NAMZ-2
C KNM GETS BACK +2 AT RETURN FROM RESPC.
JRD=JRD+1
NXX=NRD(JRD)
CZ NAME=0
CZ NAMZ=0
44 RSTAFF=0
13 YN=0
IF(SN.NE.200)GO TO 8
YN=-1
IF(YCLEF.GT.1)YCLEF=-1
IF(YSIG.GT.1)YSIG=-1
IF(YMTR.GT.1)YMTR=-1
8 ZLFT=XLFT+.5
RNUM=PGNUM
C SIZE FACTOR FOR PAGE NUMBER FINDER (MAYBE).
DO 18 K=1,JPQ
18 Q(K)=0
C ZERO IT FOR FUTURE SAFETY
RLFT=RLFT-3
C TO CATCH 1ST SLURS.
DO 6 K=1,ITEM
R5=-1
R=CODEN(KWDS,K,RN,J)
IF(R.EQ.0)GO TO 6
C DUPLICATE BARS WERE CHANGED TO CODE 0
RWD=RN(J)
C RWD IS WDCNT OF EACH ITEM
IF(R.NE.10)GO TO 800
CCX IF(RWD.LT.4)GO TO 80
CCX IF(RN(J+6).GT.RNUM)GO TO 6
C SKIPS PAGE NUMS. (I.E. P7 > 2)
IF(RN(J+6).GE.100)GO TO 810
C SAVE NUMBER IF SIZE FACTOR(R6) IS +100 (JUST LIKE CODE 16)
IF(RWD.LT.5)GO TO 80
IF(RN(J+7).GE.3)GO TO 6
IF(RWD.LT.6)GO TO 80
RN(J+6)=RNMSZ
RN(J+4)=RNMHT
C THE ABOVE SET HEIGHT AND SIZE OF REHEARSAL NUMS.
GO TO 810
800 IF(R.NE.4)GO TO 80
IF(RN(J+4).GE.1000)GO TO 801
C FINDS DBL BARS OF ALL SORTS
IF(RWD.GT.2)GO TO 182
C FOUND A BAR LINE
801 IF(RN(J+3).LT.ZLFT)GO TO 6
C DROPS BAR LINE AT LEFT OF STAFF.
IF(IPG.EQ.0)GO TO 382
IF(RWD.LT.2)GO TO 382
LL=RN(J+4)/100.
RR=100*LL+1.0
RN(J+4)=RR
C THIS PRESERVES DOUBLE BARS OF ALL SORTS.
CCC IF(RN(J+2).NE.0)GO TO 182
C KEEP BAR LINES ON STAVES >0 BUT DON'T COUNT THEM.
382 CALL DBAR(K,ITEM,J)
IF(YN.EQ.0)GO TO 810
CALL ADRST(KPN,RR)
GO TO 6
182 RN(J+1)=44
C CHANGES CODE NUM
IF(RWD.LT.5)GO TO 80
IF(RN(J+7).GE.3)GO TO 6
C SKIP HEAVY BRACKETS.
IF(RWD.LT.4)GO TO 80
A=RN(J+6)
IF(A.EQ.0)GO TO 80
IF(A.GE.199)RN(J+6)=200
80 IF(R.NE.16)GO TO 180
IF(IPG.EQ.0)GO TO 180
IF(RN(J+5).GE.100)RN(J+2)=SN
C CATCHES WANTED TEXT ON OTHER LINES. (P5>100)
CXXX IF(RN(J+5).GT.RLTRSZ)RN(J+5)=RLTRSZ
C LIMITS SIZE OF LETTERS. ADJUST RLTRSZ TO SUIT. (SET AT 1.0 NOW)
180 RSN=RN(J+2)
IF(IPG)GO TO 2011
ISN=RSN
RSN=SN
C THE STAFF NUM.
2011 IF(R.NE.3)GO TO 3801
IF(IPG)GO TO 2111
CLEF=RCL(ISN)
GO TO 4801
2111 IF(RN(J+6).LT.100)GO TO 4804
RN(J+2)=SN
C SIZE +100 (R6) IS PUT IN ALL PARTS (FOR P,PP,PPP,MF, ETC.)
GO TO 4803
4804 IF(YCLEF)GO TO 4801
IF(RSN.NE.SN)GO TO 6
4801 RR=CLEFN(RN,J)
C GET CLEF NUMBER.
IF(RR.EQ.CLEF)GO TO 6
C SKIP DUPLICATE CLEFS.
IF(RR.GT.4)GO TO 4800
C 0=TREB 1=BASS 2=ALTO 3=TENOR 4=PERCUSSION CLEF.
IF(IPG)GO TO 17
RCL(ISN)=RR
IF(RCLEF(ISN).EQ.99)RCLEF(ISN)=RR
C SAVE FIRST CLEF ON EACH STAFF
GO TO 1800
CP16 FORMAT(' CLEF=',F2.0,' --CHANGE TO--',$)
CP TYPE 16,RR
CP ACCEPT 5,RR
17 R5=RR
CLEF=RR
YCLEF=0
GO TO 1800
4800 IF(RSN.NE.SN)GO TO 6
4803 RN(J+1)=33
GO TO 1800
4802 YCLEF=0
C CATCHES CLEF AFTER FIRST RESTS.
GO TO 6
3801 IF(R.NE.17)GO TO 3800
CCX IF(IPG)GO TO 2211
IF(IPG.EQ.0)GO TO 3802
CCX XSIG=RSIG(ISN)
CCX GO TO 3802
2211 IF(YSIG)GO TO 3802
IF(RSN.NE.SN)GO TO 6
3802 RR=RN(J+5)
CCX IF(RR.EQ.XSIG)GO TO 6
IF(RR.EQ.RSIG(ISN))GO TO 6
YSIG=0
CCX XSIG=RR
C SKIPS DUPL. KEY SIGS. ***** DO I NEED THIS??
IF(RSIG(ISN).EQ.99)RSIG(ISN)=RR
C SETS UP KSIG ONCE ONLY.
CC IF(IPG.EQ.0)RSIG(ISN)=RR
GO TO 1800
C**** OR↑↑↑↑ GO TO 81 ???***
3800 IF(R.EQ.8)GO TO 6
C OMIT ALL STAVES FOR NOW
IF(R.NE.18.)GO TO 81
CP IF(IPG)GO TO 2311
XMTR=RMETER(ISN)
GO TO 1801
2311 IF(YMTR)GO TO 1801
IF(SNMTR.EQ.200.)SNMTR=RSN
C SO IT WON'T REPEAT METERS.
C CHECK ALL METERS IF LINE HAS NOT THIS INST.
IF(RSN.NE.SNMTR)GO TO 6
1801 RA=RN(J+5)*100.+RN(J+6)
C THE TIME SIG.
IF(XMTR.EQ.RA)GO TO 6
XSIG=RA
XMTR=RA
YMTR=0
IF(IPG)GO TO 181
RMETER(ISN)=RA
GO TO 1800
181 RR=RN(J+3)
DO 281 LS=1,L-1
IF(CODEN(KPN,LS,Q,KW).NE.R)GO TO 281
C LOOK FOR SAME METER IN SAME POS. (DIF. METER WILL OVERPRINT)
IF(XSIG.NE.Q(KW+5)*100.+Q(KW+6))GO TO 281
IF(Q(KW+3).EQ.RR)GO TO 6
281 CONTINUE
GO TO 1800
81 IF(RSN.NE.SN)GO TO 6
1800 IF(IPG.EQ.0)GO TO 5800
IF(RN(J+3).LT.XLFT)GO TO 6
C OMIT SOME THINGS TO LEFT OF STAFF BEGINNING.
GO TO 6800
5800 IF(R.NE.7)GO TO 282
6800 IF(R.LT.4)GO TO 810
IF(R.EQ.44)GO TO 6801
IF(R.GT.7)GO TO 810
C NEXT FOR ITEMS WHERE P6 MAY GO PAST 200.
IF(RWD.LT.5)GO TO 810
6801 A=ABS(RN(J+7))
IF(A.LT.2.OR.A.GT.7)GO TO 82
C CATCHES TRILL WIGGLE OVER END OF LINE.
282 IF(R.NE.5)GO TO 810
IF(RN(J+3).LT.RLFT)GO TO 6
C OMIT ENTERING SLURS. NEXT CHECKS FOR SLUR OVER END OF LINE
82 IF(RN(J+6).GE.199.)RN(J+6)=200.
C ****** 200.0 ABOVE IS SUBJECT TO CHANGE!
810 KL=0
IF(R.GT.2)GO TO 1810
C NEXTS FINDS NOTES AND RESTS WITHOUT RHYTHM (P7 OR P9)
IF(RN(J+3)-PQ.GT.SPCPG)GO TO 1810
C JUMP IF NOT IN SAME VERT. POS.
IF(RT.NE.R)GO TO 1810
C JUMP IF PREVIOUS ITEM WASN'T THE SAME
RS=9-R*2
IF(RWD.GE.RS)GO TO 1810
C JUMP IF WDCNT IS BIG ENOUGH
KL=RS-RWD
C SEND THE DIFFERENCE TO THE SUBROUTINE AND ADD A RHYTHM (1.0)
1810 IF(IPG)RN(J+2)=0
C ALWAYS SET STAFF NUM TO 0 FOR PARTS.
CALL QRN(J,KPN,K)
C PUTS NEEDED THINGS INTO Q ARRAY
RT=R
PQ=RN(J+3)
C SAVE THINGS FOR NEXT TIME AROUND LOOP.
6 CONTINUE
C******↓↓↓↓↓↓ RHYTH RESET ↓↓↓↓↓↓↓↓
CALL SORT(KPN)
C SORTS Q ARRAY, PUTS IT BACK INTO RN
23 LL=0
C TO 'MOVE' INSTEAD OF 'JUSTIFY'
CC J=1
CC223 R=CODEN(KWDS,J,RN,K)
CC IF(R.LE.3.OR.R.EQ.17.OR.R.EQ.18)GO TO 123
CC J=J+1
CC GO TO 223
CC123 R8=ENDLN-RN(K+3)+2
CC R4=0
CC R7=0
CC RS=0
CC R9=0
CC R5=10000
C INSERT?? →→ IF(R8.GT.0)R9=200.
CC33 CALL PTMOVE(RN,KWDS)
C******* IS KQ SUPPOSED TO BE 0!!!!!!!!?????
CALL SHFT0(KQ)
20 CALL RESPC
KNM(JNM)=KNM(JNM)+2
C UPDATE THE FILE NAME
GO TO 1344
END
SUBROUTINE READX(IDEV,NAME,IEXT,KEND,NUMS)
COMMON /PTR/INP(72)
DIMENSION FORM2(5),FORMT(5),NUMS(30)
DATA FORMT(1)/'('/,FORM2/'A1,','A2,','A3,','A4,','A5,'/
1, FORM3/'30I)'/
1 FORMAT(72A1)
CC IEXT='DMD'
CC ACCEPT 1,INP
KEND=0
C IDEV=DEVICE NUMBER (1=DSK, 5=TTY)
READ(IDEV,1,END=10)INP
DO 2 K=2,72
IF(INP(K).EQ.' ')GO TO 3
2 IF(INP(K).EQ.'.')GO TO 4
3 FORMT(3)=FORM3
FORMT(4)=' '
FORMT(5)=' '
5 FORMT(2)=FORM2(K-1)
REREAD FORMT,NAME,NUMS
RETURN
4 FORMT(3)=FORM2(1)
C CATCHES DOT
DO 7 N=K+1,72
7 IF(INP(N).EQ.' ')GO TO 8
8 FORMT(4)=FORM2(N-K-1)
FORMT(5)=FORM3
FORMT(2)=FORM2(K-1)
REREAD FORMT,NAME,K,IEXT,NUMS
RETURN
10 KEND=-1
END